MacWorld 1999 July/Macworld (1999-07).dmg/Shareware World/Info/For Developers/Mops 3.4.sea/Mops source/PPC source/pnuc2

Text File | 1998-12-16 | 16KB | 853 lines

marker m__pnuc2

\                    ======================
\                               I/O
\                    ======================


0    value    BUSY        \ FCB of file involved in asynchronous I/O, or zero if none.
                        \ Set from high level, not from here.  Cleared here though,
                        \  by the completion routine.

0    value    CPADDR        \ Completion routine address, or zero if none.  Also serves
                        \  as a flag that the next op is to be asynchronous.


\ *** Actually, I'm not going to attempt asynch I/O on the PPC yet, since I
\  don't want to have to worry about UPP callbacks!


\                    ===========================
\                        OTHER SYSTEM CALLS
\                    ===========================

\ we can omit all the handle and pointer stuff here in the nucleus, and just
\  use SYSCALLs in pStruct.

sysCall  FreeMem
sysCall  MaxMem
sysCall  EventAvail
sysCall  WaitNextEvent
sysCall  FindWindow
sysCall  BlockMoveData

: FREE        FreeMem  ;

    variable    growBytes

: FREEBLK    growBytes  MaxMem  ;

: EVENT?        \ ( mask -- b )
    fEvent  EventAvail 0<>  ;

: ?EVENT    event?  ;            \ legacy name

: NEXTEVENT        \ ( ^event mask -- b )
    swap
    TEidle_vect
    sleepTicks
    MMRgn
    WaitNextEvent
;

variable  WPtr

: FIND-WINDOW    \ ( point -- part# ^window )
    WPtr
    FindWindow
    WPtr @  ;



\                =========================
\                LOW-LEVEL STRING HANDLING
\                =========================


: FILL  { addr len char -- }
    len  0EXIT
    len FOR
        char  addr c!
        1 ++> addr
    NEXT
;

: ERASE        \ ( addr len -- )
    0 fill  ;

: BLANKS    \ ( addr len -- )
    $ 20  fill  ;


: (S=)  { addr1 addr2 len -- b }
    len
    FOR    addr1 c@  addr2 c@  <>
        IF  UNFOR  false  EXIT  THEN
        1 ++> addr1  1 ++> addr2
    NEXT
    true  ;



: S=  { addr1 len1 addr2 len2 -- b }
    len1 len2 =
    IF        addr1 addr2 len1 (s=)
    ELSE    false
    THEN
;



(*    MOVE and ALIGNED_MOVE.
    There's a small problem with MOVE in that it is required by the standard to
    move the data exactly even if the areas overlap, without propagation effects.
    "Undefined on overlap" would have allowed better optimization possiblities,
    although there are probably some situations where the other behavior is
    better.  Anyway we provide both.  We do the "undefined on overlap" with
    ALIGNED_MOVE, which also requires the beginning addresses to be aligned,
    which they usually are anyway.  For MOVE, we call BlockMoveData, which
    does the right thing, and does it well, especially for the longer moves.
    There's about a 28 instruction overhead, but the actual moves are optimum
    for whatever processor we're running on.  So even for ALIGNED_MOVE, we
    call BlockMoveData if the move is long, since for a long enough move there'll
    always be an advantage in using a processor-specific optimized sequence.

    We assume that we're not moving code, only data, so we use BlockMoveData
    rather than BlockMove which flushes the caches.
    Note we also made this assumption on the 68k, since although we used
    BlockMove (BlockMoveData not being available on all systems) if possible
    we optimized small moves to some inline MOVE instructions without a cache
    flush.

    Note also that in a future version the code given here for ALIGNED_MOVE
    might not always be called if the byte count is a literal.  In this case
    we could sometimes generate a better inline sequence.
*)


: MOVE    \ ( src dst len -- )
    dup NIF  drop 2drop  EXIT  THEN
    BlockMoveData  ;

$ BD36 ' move  2- w!                \ move_h handler code

: ALIGNED_MOVE  { src dst len \ cnt -- }
    len 0<=  ?EXIT
    len 32 <=
    IF    len 2 >>  -> cnt
        cnt FOR        src @  dst !
                    4 ++> src  4 ++> dst
            NEXT
        len 3 and  -> cnt
        cnt FOR        src c@  dst c!
                    1 ++> src  1 ++> dst
            NEXT
    ELSE
        src dst len BlockMoveData
    THEN
;

\ $ BD37 ' aligned_move  2- w!        \ alignedMove_h handler code


: CMOVE  { src dst len -- }
    len FOR
        src c@  dst c!
        1 ++> src  1 ++> dst
    NEXT
;


: UPPER  { addr len -- }
    len FOR
        addr c@
        & a  & z  within?
        IF    $ 20 xor  addr c!  ELSE  drop  THEN
        1 ++> addr
    NEXT
;


(*    These words are used by the input parsing section.

    SCAN ( addr len c -- addr' len' ) searches the string ( addr len )
    for the character c.  addr' is the address of the matching char,
    and len' is the remaining length (including the matching char).  If no
    match, len' will be zero.

    Class String+ provides a more complete implementation in its
    chsearch: method, which has case handling.  In the 68k version,
    SCAN only handles a 16-bit length - we don't have this restriction
    in the PPC version, although if you exploit this feature your
    code won't work on the 68k.
*)


: SCAN { addr len char -- addr' len' }

    len FOR
        addr c@ char =
        IF  UNFOR  addr len  EXIT  THEN
        1 ++> addr  1 --> len
    NEXT
    addr 0
;


: SKIP  { addr len char -- addr' len' }

    len FOR
        addr c@ char <>
        IF  UNFOR  addr len  EXIT  THEN
        1 ++> addr  1 --> len
    NEXT
    addr 0
;

: /STRING  { addr len n -- addr' len' }
    addr n +
    len  n -
;


\                ==========================
\                    INPUT PARSING etc.
\                ==========================

: SOURCE    \ ( -- addr len )
    src-start src-len  ;


: REST        \ ( -- addr len )
    src-start    >in @ +
    src-len        >in @ -
;

: SCAN-SRC  { c -- }
    \ Scans the input stream for c.  Leaves the source
    \ updated to the next character, (so it could be empty if the found char
    \ was the last in the buffer) or overshot if none found (>IN exceeding
    \ SRC-LEN).  The caller will need to check for this.

    rest c scan
    src-len swap - 1+  >in !
    drop  ;


: SKIP-SRC  { c -- }
    \ Skips consecutive delimiters equal to c in the source.
    \ Leaves source updated to the next character, or empty if none.

    rest c skip
    src-len swap -  >in !
    drop  ;


: SKIP-SRC+  { c -- }
    \ Skips consecutive delimiters equal to c in the source.
    \ If the source gets exhausted before a non-delimiter is found,
    \ keeps calling REFILL to get more.

    BEGIN
        c skip-src
        >in @  src-len <  ?EXIT        \ out on success
        refill                        \ get next input line
    NUNTIL                            \ loop if we got it
    154 die            \ "unexpected end of file"
;


: PARSE  { c \ len -- addr len }
    \ Scans the source for delimiter c.  Returns
    \ the addr and len of the parsed string, and updates the source
    \ to the remaining string.

    >in @
    c scan-src
    >in @  over -  1-  -> len
    src-start +  len
;


: PARSE-WORD  ( c -- addr len )
    \ As for PARSE, but any consecutive initial delimiters are
    \ skipped.  If the input is exhausted in the process,
    \ REFILL is called to get more.

    dup skip-src+ parse  ;


: PARSE-DLM-STR  { c -- addr len }
    \ Scans the source for a string delimited at the
    \ start and end by c.  Everything is skipped before the first delimiter.
    \ If the source gets exhausted in the process, REFILL is called to get
    \ more.

    BEGIN
        c scan-src
        >in @  src-len <
        IF    c parse  EXIT  THEN        \ found
        refill
    NUNTIL
    154 die            \ "unexpecte end of file"
;


: "STR"  ( -- addr len )  \ Scans for a string delimited by "..."

    & "  parse-dlm-str  ;


: PLACE  { addr1 len addr2 -- }
    \ Converts string ( addr1 len ) to a counted string at addr2.
    \ Appends 3 zero bytes, which may be needed for padding, as
    \ well as making it a valid C string.

    addr2 len + 1+  3 erase            \ append zero bytes
    len addr2  c!                    \ store count byte
    addr1  addr2 1+  len  cmove        \ move string bytes over
;


: WORD  { c \ addr -- addr }
    \ Parses the source using c as the delimiter (using PARSE-WORD).
    \ Moves the resulting string as a counted string to the CDP with
    \  alignment, and returns this address.
    \ We do the alignment since this may be the start of a new
    \  dictionary header.

    c parse-word
    CDP #align4  -> addr
    addr place
    addr
;


: WORD" ( -- addr )
    & "  word  ;


: MWORD  ( -- addr )
    \ "Mops word".  Called by DEFINED? which is called
    \ by INTERPRET.
    \ Calls WORD with a blank as delimiter, and converts the string
    \ to upper case.  Leaves counted string at addr (will be HERE).

    bl word
    case_in_names?  ?EXIT
    dup count upper  ;


: (,STR)  ( addr len --)
    tuck here place
    1+ #align4 allot  ;


: ,STR  ( c -- )
    \ c is delimiter.  Adds the following text until delimiter
    \ to the DATA AREA as a counted string.

    parse  (,str)  ;


: ,DLM-STR  ( c -- )
    \ Scans the source for a string delimited at the
    \ start and end by c, then adds it to the dictionary.

    parse-dlm-str  (,str)  ;


: ,"  ( -- )        \ Adds text till " to the dictionary.
    & "  ,str  ;


: ,"STR"  ( -- )    \ Adds text delimited by " at the start and end.
    & "  ,dlm-str  ;


\ .( - see below, after TYPE

: (
    & )  parse  2drop  ;        ppc_immediate

: \
    0 -> src-len  ;                ppc_immediate



\                    ======================
\                        SCREEN OUTPUT
\                    ======================


\ First, the sysCalls and low-level stuff:

sysCall  MoveTo
sysCall  EraseRect
sysCall  SetOrigin
sysCall  Line
sysCall  ScrollRect
sysCall  GetPen
sysCall  GetPenState
sysCall  SetPenState
sysCall  PenMode
sysCall  DrawChar
sysCall  DrawText


: HOME
    8 15  MoveTo  ;

: CLS
    fpRect  EraseRect  ;

: SCROLL  { x y -- }
    emit?  0EXIT
    fpRect x y theRgn  ScrollRect  ;

: >ORIGIN    \ ( x y --)
    SetOrigin  ;

: GOTOXY    \ ( x y -- )
    MoveTo  ;

: @XY        \ ( -- x y )
    tempVbl GetPen
    tempVbl 2+ w@
    tempVbl    w@
;

: .CURS  ( -- )
    emit?    0EXIT
    curs?    0EXIT
    tempVbl GetPenState
    10  PenMode
    7 0  Line
    tempVbl SetPenState
;


: CONTBOT  ( -- n )
    thePort $ A0 + w@  ;

: CONTTOP  ( -- n )
    thePort $ 9C +  w@  ;

: #LEAD  { \ addr -- n }
    thePort -> addr

    thePort $ 4A + w@
    dup NIF        \ zero point size, i.e. no font set.  We just return 4 so Scroll
                \  doesn't crash.
        drop 4  EXIT
    THEN
    120 *  50 +  100 /
;


: #LINES  ( -- n )
    contBot contTop -  #lead /  1-  ;


: BOTTOM  ( -- n )
    #lead #lines 1- *
    15 +  contTop +  ;


\            ---------------- CR -----------------

: (CR)  ( -- )
    .curs
    @xy  nip 8 swap
    dup bottom >=
    IF    0
        #lead negate  scroll
        gotoXY
    ELSE
        #lead +  gotoXY
    THEN
    .curs
;

' (cr)    sVect    CRVEC

: CR    crVec  ;


\            ---------------- EMIT -----------------

: (EMIT)  { c -- }
    emit?  0EXIT
    c  $ D =
    IF    crVec
    ELSE
        .curs  c DrawChar  .curs
    THEN
;

' (emit)    sVect    EMITVEC
' (emit)    sVect    ECHOVEC

: EMIT        \ ( c -- )
    1 ++> out  emitVec  ;

\ Doug H wants the prompt vectored:

: (ok)    & >  emit  ;

' (ok)  vect  OK


\            ---------------- TYPE -----------------

: (TYPE)  { addr len -- }
    emit?  0EXIT
    .curs
    addr 0 len  DrawText
    .curs
;

' (type)    sVect    TYPEVEC

: TYPE  ( addr len -- )
    dup ++> out  typeVec  ;


: .(
    & )  parse  type  ;            ppc_immediate


\            -------------- SPACE & SPACES ---------------

: SPACE        bl emit  ;


: (SPACES)  { n -- }
    emit?  0EXIT
    n 0<=  ?EXIT

    n padLen min  -> n
    pad n bl fill
    pad n  (type)
;

' (spaces)    sVect    SPVEC

: SPACES    \ ( n -- )
    dup ++> out  spVec  ;


\ We only use (BS) internally, so we don't define a BS.

: (BS)
    .curs                    \ erases any cursor on screen
    curs?  false -> curs?
    @xy swap  6 -  8 max  swap
    2dup gotoXY  space  gotoXY
    -> curs?
    .curs                    \ draw cursor at new position
;


: +ECHO        true  -> echo?  ;
: -ECHO        false -> echo?  ;

: +CURS        true  -> curs?  ;
: -CURS        false -> curs?  ;
: CURS        curs?  ;            \ for backward compatibility


\                ===============================
\                        KEYBOARD INPUT
\                ===============================


: KEY?  ( -- b )
    $ 28  event?  ;

: ?TERMINAL  ( -- b )        \ the old name
    key?  ;


: (KEY)  { \ what -- c }

    BEGIN
        fEvent                        \ addr of our event record
        $ 843A                        \ Mask - we'll accept key down, auto-key,
                                    \  mouse-down, high-level and OS events.
        nextEvent
        IF                            \ we've got something
            fEvent w@ -> what        \ get What field of fEvent
            what 3 =  what 5 = or
            IF                        \ we've got a key
                fEvent 5 + c@        \ low byte of message field is ASCII key value
                EXIT
            ELSE
                what 23 =
                IF                    \ High-level event - presumably oapp.
                                    \ We'll just ignore it.
                THEN
            THEN
        THEN
    AGAIN
;


' (key)    sVect    KEY

forward        get_$input

:f get_$input    pad 0  ;f


: bs_acc
    #tib @                \ at start of TIB?
    IF    (bs)            \ no - fix screen
        -1 #tib +!        \ and back up
    ELSE
        4 beep            \ yes - beep
    THEN
;


: key_acc  { \ c loop? -- c }
        \ Reads one key for ACCEPT.  Handles backspaces and tabs.

    BEGIN
        false -> loop?
        key -> c
                            \ first we check for the chars which we don't echo
        c 8 =
        IF  bs_acc                    \ handle backspace
        ELSE
            c $ FF =
            IF                        \ ignore FF

            ELSE            \ we echo everything else and don't loop
                c 3 =
                IF    $ D -> c        \ <enter> replaced with <return>
                ELSE
                    c 9 =
                    IF    bl -> c        \ tab replaced with blank
                    THEN
                THEN
                c echoVec            \ echo char however we're set up to do it
                c  EXIT
            THEN
        THEN
    AGAIN
;


: ACCEPT  { addr max_len \ c -- #chars }

    0 #tib !

\ Is there pending input from the Mops window?

    get_$input  ?dup
    IF                    \ yes - move it to the destination.  We can
                        \  assume special chars have been filtered.
        max_len min
        dup #tib !
        addr swap cmove  EXIT
    THEN
    drop

    BEGIN
        key_acc  -> c
        c $ D =
        IF  #tib @  EXIT  THEN

        #tib @ max_len <
        IF  c  addr #tib @ + c!        \ still room in buff - store char
            1 #tib +!
        THEN
    AGAIN
;


: SET_SOURCE
    TIB        -> src-start
    #tib @    -> src-len
    0 >in !
;

: QUERY
    TIB TIBlen  accept drop
    set_source
    0 -> source-ID
;

:f REFILL ( -- b )    \ attempts to (re)fill the input stream with another line.
    source-ID dup
    NIF                    \ it's from the keyboard
        drop  query
        true
    ELSE
        -1 =
        IF                \ it's from an EVALUATEd string - none left
            false
        ELSE            \ it's from a file
            fRefill        \ - fRefill does the job, and returns the flag.
        THEN
    THEN
    1 ++> #lines_read
;f


\                    =====================
\                        NUMBER INPUT
\                    =====================


: >NUMBER  ( ud-lo ud-hi ) { addr len -- ud-lo' ud-hi' addr' len' }
    len 0>
    IF
        BEGIN
            addr c@  1 ++> addr
            base digit
            NIF    1 --> addr  false
            ELSE
             ( ud-lo ud-hi digit )
                 swap base * rot base um*  d+
                dpl 0>= IF  1 ++> dpl  THEN
                1 --> len
                len 0>
            THEN
        NUNTIL
    THEN
    ( ud-lo' ud-hi' )  addr len
;


: ?NOTFOUND  ( flag -- )
    NIF     -13 die  THEN        \ "undefined word"
;


: NUM?  { addr len \ start neg? done? -- n true | -- n-lo n-hi true | -- false }

    false -> neg?  false -> done?

    len NIF  false  EXIT  THEN

    addr c@ & - =
    IF            \ 1st char was minus
        true -> neg?
        1 ++> addr  1 --> len
    THEN
    addr -> start                \ remember initial addr
    -1 -> dpl                    \ no decimal point seen yet
    0 0                            \ initial number is a double zero
    BEGIN
        addr len  >number        \ accumulate digits into number
        -> len -> addr            \ update string addr & len
        len
        IF    addr c@  & . =
            IF  addr -> dpl
                1 ++> addr  1 --> len
            ELSE
                true -> done?
            THEN
        ELSE
            true -> done?
        THEN
    done?
    UNTIL

\ we've hit a non-digit or the string is exhausted.

    len IF            2drop false  EXIT  THEN        \ 'number' not completed - probably
                                                \  bad char in number
    addr start = IF    2drop false  EXIT  THEN        \ no chars processed - not a number

    dpl 0>=
    IF                \ decimal point seen - it's a double number
        neg? IF  dnegate  THEN
    ELSE
        drop        \ want a single number - drop hi cell
        neg? IF  negate  THEN
    THEN
    true
;

: NUMBER  ( addr -- n )        \ returns the number at addr, or if none,
                            \ gives "undefined word" error.
    count  num? ?notFound  ;


\ LITERAL is immediate so we'll leave it till the end.

\    head    $47,LITERAL,literal        ; LITERAL
\    callh    hLiteral
\    RTS


\            =============================
\                       NUMBER OUTPUT
\            =============================

: HOLD  ( c -- )
    1 --> hld  hld c!  ;


: <#  ( d -- d )
    pad -> hld  ;

: #>  ( d -- )
    2drop
    hld pad over -  ;


: SIGN  ( n -- )
    0< IF  & -  hold  THEN  ;

(*
: #
    drop        \ get rid of hi-order cell (assumed to be zero)
    base  u/mod
    swap
    dup 9 > IF  7 +  THEN
    & 0  +  hold
    0
;
*)

: #
    base 0  ud/mod  2swap drop
    dup 9 > IF  7 +  THEN
    & 0  +  hold
;


: #S  ( d -- d' )
    BEGIN  #  2dup or  NUNTIL  ;

\ : HEX        16 -> base  ;
\ : DECIMAL    10 -> base  ;


: .R  { n #to-right -- }
    n abs  0
    <#  #s  n sign  #>
    #to-right over -  spaces
    type
;

: .        \ ( n -- )
    0 .r space  ;

: .H
    base  16 -> base
    swap .
    -> base  ;

: U.
    0 <# #s #>  type  space  ;


: N>COUNT
    count  $ 1F and  ;